Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH7/SRC/OBJ4PICT.CLS

Text File | 1995-10-26 | 5.6 KB | 203 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "ObjPicture"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

' Each ObjPicture object is a quadtree node.
'
' If the object is a leaf node, its Objects
' collection contains the objects to draw.
'
' Otherwise the object's children contain other
' ObjPicture objects.

' The maximum number of objects the node can hold.
Const MAX_OBJECTS = 100

' The bounds this quadtree node represents.
Public xmin As Single
Public ymin As Single
Public xmid As Single
Public ymid As Single
Public xmax As Single
Public ymax As Single

' The objects, if this is a leaf node.
Private Objects As Collection

' The quadtree children otherwise.
Public NWchild As ObjPicture
Public NEchild As ObjPicture
Public SWchild As ObjPicture
Public SEchild As ObjPicture

' ************************************************
' Find an object that contains this point.
' ************************************************
Function NearestObject(x As Single, y As Single) As Object
Dim obj As Object

    Set NearestObject = Nothing
    ' Bail out if we don't contain the point.
    If x < xmin Or x > xmax Or _
       y < ymin Or y > ymax _
       Then Exit Function

    ' Find the object.
    If Objects Is Nothing Then
        If y > ymid Then
            If x < xmid Then
                Set NearestObject = NWchild.NearestObject(x, y)
            Else
                Set NearestObject = NEchild.NearestObject(x, y)
            End If
        Else
            If x < xmid Then
                Set NearestObject = SWchild.NearestObject(x, y)
            Else
                Set NearestObject = SEchild.NearestObject(x, y)
            End If
        End If
    Else
        For Each obj In Objects
            If obj.Contains(x, y) Then
                Set NearestObject = obj
                Exit Function
            End If
        Next obj
    End If
End Function

' ************************************************
' Set the Drawn properties of the objects.
' ************************************************
Sub SetDrawn(value As Boolean)
Dim obj As Object

    If Objects Is Nothing Then
        NWchild.SetDrawn value
        NEchild.SetDrawn value
        SWchild.SetDrawn value
        SEchild.SetDrawn value
    Else
        For Each obj In Objects
            obj.Drawn = value
        Next obj
    End If
End Sub

' ************************************************
' Add an object to the Objects collection.
'
' If this gives us too many, create child nodes
' and subdivide.
' ************************************************
Sub Add(obj As Object)
    If Objects Is Nothing Then
        PlaceObject obj
    Else
        Objects.Add obj
        If Objects.Count > MAX_OBJECTS Then Divide
    End If
End Sub

' ************************************************
' Create the children and divide the object.
' ************************************************
Sub Divide()
Dim obj As Object

    ' Create the children.
    Set NWchild = New ObjPicture
    NWchild.SetBounds xmin, xmid, ymid, ymax

    Set NEchild = New ObjPicture
    NEchild.SetBounds xmid, xmax, ymid, ymax

    Set SWchild = New ObjPicture
    SWchild.SetBounds xmin, xmid, ymin, ymid

    Set SEchild = New ObjPicture
    SEchild.SetBounds xmid, xmax, ymin, ymid

    ' Divide up the children.
    For Each obj In Objects
        PlaceObject obj
    Next obj

    ' Remove the Objects collection.
    Set Objects = Nothing
End Sub

' ************************************************
' Set the bounds for this quadtree node.
' ************************************************
Sub SetBounds(x1 As Single, x2 As Single, y1 As Single, y2 As Single)
    xmin = x1
    ymin = y1
    xmax = x2
    ymax = y2
    xmid = (xmin + xmax) / 2
    ymid = (ymin + ymax) / 2
End Sub
' ************************************************
' Place this object in the proper child(ren).
' ************************************************
Sub PlaceObject(obj As Object)
Dim x1 As Single
Dim x2 As Single
Dim y1 As Single
Dim y2 As Single

    obj.Bound x1, y1, x2, y2
    If y2 > ymid And x1 < xmid Then NWchild.Add obj
    If y2 > ymid And x2 > xmid Then NEchild.Add obj
    If y1 < ymid And x1 < xmid Then SWchild.Add obj
    If y1 < ymid And x2 > xmid Then SEchild.Add obj
End Sub

' ************************************************
' Draw the picture on a Form, Printer, or
' PictureBox.
' ************************************************
Sub Draw(canvas As Object, x1 As Single, y1 As Single, x2 As Single, y2 As Single)
Dim obj As Object
Dim oldcolor As Long

    ' Bail out if we don't intersect the region
    ' we're trying to draw.
    If x2 < xmin Or x1 > xmax Or _
       y2 < ymin Or y1 > ymax _
       Then Exit Sub

    ' Draw a red box around our display region.
    oldcolor = canvas.ForeColor
    canvas.ForeColor = RGB(255, 0, 0)
    canvas.Line (xmin, ymin)-(xmax, ymax), , B  '@
    canvas.ForeColor = oldcolor

    If Objects Is Nothing Then
        NWchild.Draw canvas, x1, y1, x2, y2
        NEchild.Draw canvas, x1, y1, x2, y2
        SWchild.Draw canvas, x1, y1, x2, y2
        SEchild.Draw canvas, x1, y1, x2, y2
    Else
        For Each obj In Objects
            obj.Draw canvas
        Next obj
    End If
End Sub

' ************************************************
' Start with an empty Objects collection.
' ************************************************
Private Sub Class_Initialize()
    Set Objects = New Collection
End Sub